home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / Module source / Util < prev    next >
Encoding:
Text File  |  1994-10-08  |  7.2 KB  |  288 lines  |  [TEXT/YERK]
  1. \ Utility words for Yerk
  2. \ 10/13/84  CBD Combined with Dump.scr
  3. \ 12/16/84  CBD Made into a module
  4. \  1/04/85  cdn Moved in objList
  5. \  7/10/86  cdn Moved in .classes
  6. \  9/02/86  cdn Added Option & Shift key features to WORDS
  7. \  9/04/86  ghs Added pat
  8. \ 12/04/87  rfl modified .cline to use better format and increased clist size
  9. \ 12/04/87    rfl fixed dump format
  10. \ 10/02/90    rfl    .pause now in nucleus
  11. \ 10/26/91    rfl    added class hierarchy
  12. \ 12/14/91    rfl    modified .class to not be reentrant..runs out of stack
  13. \ 12/17/91    rfl    improved hier...someday will have browser
  14. \ 10/16/92    rfl    added listing of objects in .clist
  15. \ 11/10/93    rfl    added pause in objlist
  16. \  1/18/94    rfl    removed ?pause from words, so that module will unlock if aborted
  17. \  8/5/94    rfl    added .vects .vals
  18. \ 10/8/94    rfl    fixed .vects output by changing nfa to >name
  19.  
  20. Decimal
  21.  
  22. :Module Util
  23.  
  24. : Dump
  25.     base >R HEX CR CR
  26.     ." Dump from address: " over . CR 7 SPACES
  27.     16 0 DO I 3 .R LOOP 2 SPACES
  28.         16 0 DO I 0 <# # #> TYPE LOOP CR
  29.         OVER + SWAP DUP 15 AND XOR
  30.         DO    CR i 0 6 D.R SPACE
  31.             i 16 + i 2DUP
  32.             DO  ic@ SPACE 0 <# # # #> TYPE LOOP
  33.             2 SPACES
  34.             DO  ic@ DUP 32 < OVER 126 > OR
  35.                 IF DROP 46   THEN
  36.                 EMIT
  37.             LOOP
  38.         ?pause
  39.         16 +LOOP
  40.     CR R> -> BASE ;
  41.  
  42. \ pull name from stream and dump from its NFA
  43. : .W    @Pfa  nfa 100 Dump  ;
  44.  
  45. \ List words in dictionary
  46. : Words { \ eop wbase -- }
  47.     latest true
  48.     mods: fEvent 2048 and    \ option key is down- prompt for word name
  49.     IF    2drop " List from name:" doInDlg dup
  50.         IF    drop sFind 0= Abort" not found"
  51.             drop nfa true
  52.         THEN
  53.     THEN
  54.     mods: fEvent  512 and    \ shift key is down- prompt for address
  55.     IF    2drop " List from hex address:" doInDlg dup
  56.         IF    drop here >str255 1+ here c@ >uc
  57.             BL here count + c!        \ make usable by "number"
  58.             base -> wbase hex
  59.             here number drop 0 max latest
  60.             BEGIN 2dup pfa lfa @ <    \ find the nearest word
  61.             WHILE pfa lfa @
  62.             REPEAT swap drop true
  63.             wbase -> base
  64.         THEN
  65.     THEN
  66.     0= IF exit THEN    \ Cancel button from a dialog box
  67.     getvrect: fWind drop 15 - 6 / 20 / 20 * 21 - -> eop 2drop
  68.     Base -> wbase HEX  Cr Cr 0 -> out
  69.     BEGIN
  70.         dup dup 6 .R
  71.         dup  1+ C@
  72.         IF  space ID.
  73.         ELSE  ."  Null" drop
  74.         THEN out eop >
  75.         IF  Cr 0 -> Out
  76.         ELSE  20 out over mod - spaces
  77.         THEN  pfa lfa @ dup 0=
  78.         ?terminal                        \ don't use ?pause, because abort won't
  79.                                         \ unlock module
  80.           IF (key) drop cr .pause (key)
  81.              cr 0 -> out 32 > IF drop true THEN
  82.           THEN
  83.     UNTIL
  84.     drop Cr wbase -> Base ;
  85.  
  86. \ trav handler for finding objects of a class
  87. : ofind { theCfa theClass -- }
  88.     theCfa @ theClass =
  89.     IF cr theCfa >name dup id.  .h ?pause THEN   ;
  90.  
  91. : objList {  addr len \ theClass -- } addr len sFind
  92.     0= ?error 122
  93.     drop  ?isClass 0= ?error 122   -> theClass
  94.     cr ." Objects of class: " addr len type
  95.     'c ofind theClass trav  cr ;
  96.  
  97. 0 value cList
  98. 0 value level
  99. 0 value #obs
  100.  
  101. hex    \ changes text in place
  102. Create >lc    ( addr len -- addr len )
  103.     2e17    w,    \         move.l    (sp),d7
  104.     206f0004 ,    \         move.l    4(sp),a0
  105.     d1cb    w,    \         adda.l    a3,a0
  106.     5387    w,    \         subq    #1,d7
  107.     1018    w,    \ lp    move.b    (a0)+,d0
  108.     0c000041 ,    \         cmpi.b    #65,d0
  109.     6b0e    w,    \         bmi.s    out
  110.     0c00005a ,    \         cmpi.b    #90,d0
  111.     6e08    w,    \         bgt.s    out
  112.     d03c0020 ,    \         add.b    #32,d0
  113.     1140ffff ,    \         move.b    d0,-1(a0)
  114.     51cfffe8 ,    \ out    dbra    d7,lp
  115. next,
  116. decimal
  117.  
  118. \ trav handler for finding objects of a class
  119. : obfind { theCfa theClass \ len -- }
  120.     theCfa @ theClass =
  121.      IF cr level 1+ 2* spaces theCfa >name dup .h 2 spaces n>count -> len
  122.         here len cmove here len >lc type     \ move name to here
  123.         1 ++> #obs
  124.      THEN  ;
  125.  
  126. ' meta constant lastCl
  127.  
  128. \  Handler to add all classes to cList during a Trav
  129. : addClass { theCfa parm -- }
  130.     theCfa  lastCl >
  131.     IF  theCfa 4+ ?IsClass
  132.         IF  add: cList
  133.         ELSE drop
  134.         THEN
  135.     THEN ;
  136.  
  137. : fillClist   clear: clist 0 add: clist 'c addClass 0 trav   ;
  138.  
  139. \ ( ind -- ^super )
  140. : superOF  at: cList  sfa @  ;
  141.  
  142. \ find the next subclass for the given superclass ptr
  143. : nextSub { ^sup start \ bool -- subInd t OR f }
  144.     0 -> bool
  145.     size: cList  start
  146.     DO  i superOF  ^sup =
  147.         IF  i true -> bool  Leave
  148.         THEN
  149.     LOOP bool ;
  150.  
  151. : tab 6 * @xy drop - 6 / spaces ;
  152.  
  153. \ print a line of data for this class
  154. : .cline ( ind -- )
  155.     cr level 2* spaces
  156.     at: cList  dup dup nfa 4 tface id. 0 tface
  157.     dup dfa w@ 35 tab ." Dlen:" .  dfa 2+ w@ 46 tab ." Width:" . 
  158.     'c obfind swap trav  ;
  159.  
  160. \ patch .cline .cline1
  161.  
  162. \ ( ind -- ind subInd t OR ind f )  try to nest into subclass
  163. : ?sub  dup at: clist 0 nextSub  ;
  164.  
  165. \ ( ind -- newInd t or f )  try to find a peer class
  166. : ?peer
  167.     dup superOF lastCL =
  168.     IF false  THEN
  169.     dup superOF  swap 1+ nextSub  ;
  170.  
  171. : findPeer { ind  -- ind }
  172.     BEGIN ind ?peer                        \ does it have a peer class?
  173.           IF -> ind true                 \ yes, so get out
  174.           ELSE -1 ++> level    level 0=    \ no, so pop up and do again
  175.                 IF 0 -> ind true
  176.                 ELSE -> ind false
  177.                 THEN
  178.           THEN
  179.     UNTIL ind  ;
  180.  
  181. : classTrav { ind -- }
  182.     BEGIN ?terminal
  183.           IF (key) drop cr .pause (key)
  184.              cr 0 -> out 32 > IF exit THEN
  185.           THEN
  186.           ind .cline
  187.           ind ?sub                            \ does it have a subclass?
  188.           IF   1 ++> level -> ind            \ yes, so dip down and save last class index
  189.           ELSE findPeer    -> ind                \ otherwise find next peer
  190.           THEN
  191.           ind not
  192.     UNTIL ;
  193.  
  194. : .cl  size: clist 0 DO i at: clist cr nfa id. LOOP  ;
  195.  
  196. : .classes 0 -> level 0 -> #obs
  197.     400 heap> Ordered-Col -> cList
  198.     fillClist  size: clist 1-  classTrav level 0 do drop loop cr cr
  199.     size: clist ." number of classes is " . cr 
  200.     #obs ." number of objects is " . cr
  201.     dispose> cList ;
  202.  
  203. rect pbox
  204.  
  205. \ Display the system pen patterns
  206. : pat { \ pattern -- }
  207.     0 -> pattern -curs cls
  208.     1 8 50 38 put: pbox 6 0
  209.     DO    7 0
  210.         DO    pattern 38 = IF 3 sysPat +base call PenPat THEN
  211.             55 0 offset: pbox  pattern sysPat fill: pbox  draw: pbox
  212.             getBotX: pbox 38 -  getBotY: pbox 9 +  gotoxy  pattern .
  213.             1 ++> pattern
  214.         LOOP
  215.         -385 40 offset: pbox
  216.     LOOP
  217.     0 sysPat +base call PenPat
  218.     CR +curs
  219. ;
  220.  
  221.  
  222. \ ************
  223. \ : (chain) { myobj \ tab -- } cr 0 -> tab
  224. \         BEGIN  2 ++> tab myObj sfa @ -> myObj
  225. \                myObj nfa n>count 2dup tab spaces type cr " OBJECT" s=
  226. \         UNTIL ;
  227.  
  228. : (chain) { myObj \ tab -- } 40 heap> ordered-col -> clist
  229.         cr 0 -> tab myObj add: clist
  230.         BEGIN    myObj sfa @ -> myObj
  231.                 myObj add: clist
  232.                 myObj nfa n>count  " OBJECT" s=
  233.         UNTIL 
  234.         size: clist 0
  235.         DO  2 ++> tab last: clist nfa n>count tab spaces type cr
  236.             size: clist 1- remove: clist
  237.         LOOP dispose> clist ;
  238.  
  239. : hc'
  240.     @word count sfind
  241.     IF drop (chain) THEN ;
  242.  
  243. : hier  " List class hierarchy of class:" doInDlg
  244.         IF  sFind 0= Abort" not found"
  245.             drop ?isclass IF (chain) ELSE abort" not a class" THEN
  246.         THEN ;
  247.  
  248. \ : (.val) { thecfa len -- }
  249. \     theCfa @ valcode =
  250. \     IF cr thecfa >name
  251. \         n>count dup -> len
  252. \         type thecfa 12 + @ 30 len - spaces
  253. \         dup 12 .r .h ?pause THEN ;
  254. \ 
  255. \ : .vals 'c (.val) 0 trav ;
  256.  
  257. : (.val) { thecfa len \ val myBase -- }
  258.     theCfa @ valcode =
  259.     IF cr thecfa >name
  260.         n>count dup -> len
  261.         type thecfa 12 + @ -> val
  262.         val bin>asc dup ++> len
  263.         24 len - spaces type
  264.         base -> myBase
  265.         5 spaces
  266.         hex val 0 over abs swap <# #s sign #> dup -> len
  267.         10 len - spaces type myBase -> base
  268.     THEN ?pause ;
  269.  
  270. : .vals curs -curs 'c (.val) 0 trav -> curs ;
  271.  
  272.  
  273. : (.vects) { thecfa len \ val myBase -- }
  274.     theCfa @ vectcode =
  275.     IF cr thecfa >name
  276.         n>count dup -> len
  277.         type thecfa 12 + @ -> val
  278.         base -> myBase
  279.         hex val 0 <# #s #> dup ++> len
  280.         24 len - spaces type myBase -> base
  281.         5 spaces val >name id.
  282.     THEN ?pause ;
  283.  
  284. : .vects curs -curs 'c (.vects) 0 trav -> curs ;
  285.  
  286.  
  287. ;Module
  288.